Shareware Overload Trio 2/Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO/dir42/db_xl_vb.zip/DB-XL.FRM

Text File | 1994-04-07 | 14KB | 484 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   5460
   ClientLeft      =   750
   ClientTop       =   1530
   ClientWidth     =   6735
   Height          =   5865
   Left            =   690
   LinkTopic       =   "Form1"
   ScaleHeight     =   5460
   ScaleWidth      =   6735
   Top             =   1185
   Width           =   6855
   Begin FileListBox File2
      Height          =   1200
      Left            =   4080
      TabIndex        =   24
      Top             =   720
      Visible         =   0   'False
      Width           =   975
   End
   Begin PictureBox Picture2
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      Height          =   255
      Left            =   0
      ScaleHeight     =   225
      ScaleWidth      =   6705
      TabIndex        =   22
      Top             =   5205
      Width           =   6735
      Begin Label Label7
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "Label7"
         Height          =   192
         Left            =   120
         TabIndex        =   23
         Top             =   0
         Width           =   576
      End
   End
   Begin PictureBox Picture1
      AutoSize        =   -1  'True
      Height          =   1635
      Left            =   4320
      Picture         =   DB-XL.FRX:0000
      ScaleHeight     =   1605
      ScaleWidth      =   2370
      TabIndex        =   21
      Top             =   240
      Width           =   2400
   End
   Begin TextBox Text1
      Height          =   372
      Left            =   1920
      TabIndex        =   20
      Text            =   "Text1"
      Top             =   1200
      Width           =   2052
   End
   Begin CommandButton Command3
      Cancel          =   -1  'True
      Caption         =   "Exit"
      Height          =   492
      Left            =   4320
      TabIndex        =   18
      Top             =   4320
      Width           =   1932
   End
   Begin FileListBox File1
      Height          =   1200
      Left            =   4320
      TabIndex        =   9
      Top             =   2280
      Width           =   1935
   End
   Begin DirListBox Dir1
      Height          =   1752
      Left            =   2040
      TabIndex        =   8
      Top             =   2280
      Width           =   1932
   End
   Begin DriveListBox Drive1
      Height          =   288
      Left            =   4320
      TabIndex        =   12
      Top             =   3720
      Width           =   1932
   End
   Begin Frame Frame1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Database"
      Height          =   2892
      Left            =   240
      TabIndex        =   0
      Top             =   1920
      Width           =   1452
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "Paradox 3.x"
         Height          =   252
         Index           =   6
         Left            =   120
         TabIndex        =   7
         Top             =   2520
         Width           =   1212
      End
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "Btrieve"
         Height          =   252
         Index           =   5
         Left            =   120
         TabIndex        =   6
         Top             =   2160
         Width           =   1212
      End
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "FoxPro 2.5"
         Height          =   252
         Index           =   4
         Left            =   120
         TabIndex        =   5
         Top             =   1800
         Width           =   1212
      End
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "FoxPro 2.0"
         Height          =   252
         Index           =   3
         Left            =   120
         TabIndex        =   4
         Top             =   1440
         Width           =   1212
      End
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "dBase IV"
         Height          =   252
         Index           =   2
         Left            =   120
         TabIndex        =   3
         Top             =   1080
         Width           =   1212
      End
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "dBase III"
         Height          =   252
         Index           =   1
         Left            =   120
         TabIndex        =   2
         Top             =   720
         Width           =   1212
      End
      Begin OptionButton Option1
         BackColor       =   &H00C0C0C0&
         Caption         =   "Access 1.x"
         Height          =   252
         Index           =   0
         Left            =   120
         TabIndex        =   1
         Top             =   360
         Width           =   1212
      End
   End
   Begin ComboBox Combo1
      Height          =   288
      Left            =   1920
      Style           =   2  'Dropdown List
      TabIndex        =   10
      Top             =   240
      Width           =   2052
   End
   Begin CommandButton Command1
      Caption         =   "Convert"
      Default         =   -1  'True
      Height          =   492
      Left            =   2040
      TabIndex        =   11
      Top             =   4320
      Width           =   1932
   End
   Begin Label Label6
      BackStyle       =   0  'Transparent
      Caption         =   "To Spreadsheet:"
      Height          =   252
      Left            =   360
      TabIndex        =   19
      Top             =   1200
      Width           =   1452
   End
   Begin Label Label5
      BackStyle       =   0  'Transparent
      Caption         =   "Label5"
      Height          =   252
      Left            =   1920
      TabIndex        =   17
      Top             =   720
      Width           =   2292
   End
   Begin Label Label4
      BackStyle       =   0  'Transparent
      Caption         =   "From Database:"
      Height          =   252
      Left            =   360
      TabIndex        =   16
      Top             =   720
      Width           =   1452
   End
   Begin Label Label3
      BackStyle       =   0  'Transparent
      Caption         =   "Convert Table:"
      Height          =   252
      Left            =   480
      TabIndex        =   15
      Top             =   240
      Width           =   1332
   End
   Begin Label Label2
      BackStyle       =   0  'Transparent
      Caption         =   "Database or Table:"
      Height          =   252
      Left            =   4320
      TabIndex        =   14
      Top             =   1920
      Width           =   1932
   End
   Begin Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "Path of Database:"
      Height          =   252
      Left            =   2040
      TabIndex        =   13
      Top             =   1920
      Width           =   1932
   End
End
'This sample program shows you how to combine programming
'with database objects and ole automation objects.
'This program will convert a table in a database that
'the user selects, and then places it into an excel
'spreadsheet using OLE automation.

'This program assumes that you have registered Excel version
'5.0 in your registration database (REG.DAT) and that
'you installed the database component for Visual Basic 3.0
'Professional.

Dim db As database     'form level database object
Dim Connect$           'Hold connect arguments

Sub CheckEnableConvert ()

'check if table is selected and filename specified
If (combo1.Text <> "") And (Text1 <> "") Then
    command1.Enabled = True
Else
    command1.Enabled = False
End If

End Sub

Sub Combo1_Click ()

Call CheckEnableConvert

End Sub

Sub Command1_Click ()
Static flag As Integer  'flag for avoiding multiple occurances
Dim i As Integer        'loop counters
Dim j As Integer
Dim xl As object        'ole automation object
Dim Sn As Snapshot      'snapshot to hold records

If flag = 1 Then Exit Sub  'avoid multiple clicks
flag = 1

screen.MousePointer = 11   'change mousepointer

'This code performs a check for valid path and filenames
'The hidden File2 listbox has the sole purpose of validating that the
'user has entered a valid path and filename
CheckPath:
  label7.Caption = "Checking Valid Filename for Spreadsheet"
  label7.Refresh
  Text1.Tag = True            'flag if invalid filename in textbox
  Do While Text1.Tag
    On Error Resume Next
    File2.FileName = Text1.Text
    File2.Refresh
    If Err = 0 Then                 'no errors
        If InStr(Text1.Text, File2.List(0)) > 0 Then 'kill file if it exists
            Kill Text1.Text
            Text1.Tag = False
        Else                        'just a directory entry, get filename
            Text1.Text = InputBox("You Entered an Invalid Path or Filename, please enter a correct one: ", "DB to Excel Converter", Text1)
        End If
    Else
        If Err <> 53 Then           'if not "file not found", get valid path/filename
            Text1.Text = InputBox("You Entered an Invalid Path or Filename, please enter a correct one: ", "DB to Excel Converter", Text1)
        Else
            Text1.Tag = False       'valid new filename
        End If
    End If
    On Error GoTo 0
  Loop

'create our spreadsheet object
label7.Caption = "Creating Excel Object"
label7.Refresh
Set xl = CreateObject("Excel.Sheet.5")

'set up Field names as Column names
Set Sn = db.CreateSnapshot(combo1.Text)
If Sn.RecordCount > 0 Then
    Sn.MoveFirst

    'place the fields across the top of the spreadsheet
    label7.Caption = "Adding fieldnames to Spreadsheet"
    label7.Refresh
    For i = 0 To Sn.Fields.Count - 1
        xl.cells(1, i + 1).value = Sn(i).Name
    Next

    'get an accurate recordcount before we start our loop
    Sn.MoveLast
    Sn.MoveFirst

    'loop through each record
    For i = 0 To Sn.RecordCount - 1
        label7.Caption = "Looping through record " & CStr(i + 1) & " of " & CStr(Sn.RecordCount)
        label7.Refresh
        For j = 0 To Sn.Fields.Count - 1
            'add each field to the spreadsheet
            If Sn(j).Type < 11 Then
                xl.cells(i + 2, j + 1).value = Sn(j)
            Else
                xl.cells(i + 2, j + 1).value = "binary data"
            End If
        Next j
        Print
        Sn.MoveNext
    Next i

    'save the spreadsheet
    label7.Caption = "Saving Spreadsheet"
    label7.Refresh
    xl.SaveAs Text1.Text

    'quit the excel object
    xl.Application.Quit

Else
    'no records in recordset
    label7.Caption = "No Records"
    label7.Refresh

    'Pause for fraction of a second to display message
    x = Timer
    While x + .3 > Timer
    Wend
End If

'clean up
label7.Caption = "Cleaning Up"
label7.Refresh
Set xl = Nothing         'remove object variable
Set Sn = Nothing         'remove snapshot object
screen.MousePointer = 0  'restore mouse pointer
flag = 0                 'allow user to click again

label7.Caption = "Ready"
label7.Refresh

End Sub

Sub Command3_Click ()
End   'end the program

End Sub

Sub Dir1_Change ()
File1.Path = Dir1.Path
End Sub

Sub Drive1_Change ()
Dir1.Path = Drive1.Drive

End Sub

Sub File1_Click ()
'This subroutine loads the Table combo box from the selected database
Const DB_SYSTEMOBJECT = &H80000002  'constant to check for system variables
Dim i As Integer
Dim DBName$

'set up database object
If (Connect$ = "") Or (Connect$ = "Btrieve") Then
    DBName$ = File1.Path & "\" & File1.FileName
Else
    DBName$ = File1.Path
'    Set db = OpenDatabase(File1.Path, False, False, Connect$)
'    label5.Caption = File1.Path
End If

Set db = OpenDatabase(DBName$, False, False, Connect$)
label5.Caption = DBName$
label5.Refresh

'clear the tables combo box
combo1.Clear

'add new tables except system tables to the combo box
For i = 0 To db.TableDefs.Count - 1
    If (db.TableDefs(i).Attributes And DB_SYSTEMOBJECT) = 0 Then
        combo1.AddItem db.TableDefs(i)
    End If
Next i

'set the combo box to point to the first table in the list
combo1.ListIndex = 0

End Sub

Sub File1_PathChange ()
'if no items in file list box, clear the combobox
If File1.ListCount = 0 Then
    combo1.ListIndex = -1
    combo1.Clear
End If

End Sub

Sub Form_Load ()

'initialize some properties
form1.Caption = "DB to Excel Converter"
combo1.ListIndex = -1
command1.Enabled = False
Text1.Text = CurDir & "\tmp.xls"   'init the text box
label5.Caption = ""                   'clear the caption
label7.Caption = "Ready"              'init status bar

End Sub

Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
Set db = Nothing    'destroy our global database

End Sub

Sub Option1_Click (index As Integer)

'setup the connect property for Opendatabase
Connect$ = Option1(index).Caption
'set the pattern to look for in the filelist box
Select Case index
    Case 0
        File1.Pattern = "*.mdb"
        Connect$ = ""
    Case 1, 2, 3, 4
        File1.Pattern = "*.dbf"
    Case 5
        File1.Pattern = "field.ddf"
    Case 6
        File1.Pattern = "*.db"
End Select


End Sub

Sub Text1_Change ()
Call CheckEnableConvert
End Sub